home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tk8.0 / tests / defs < prev    next >
Encoding:
Text File  |  1997-08-15  |  10.7 KB  |  368 lines  |  [TEXT/ALFA]
  1. # This file contains support code for the Tcl test suite.  It is
  2. # normally sourced by the individual files in the test suite before
  3. # they run their tests.  This improved approach to testing was designed
  4. # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
  5. #
  6. # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  7. #
  8. # See the file "license.terms" for information on usage and redistribution
  9. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10. #
  11. # SCCS: @(#) defs 1.39 97/08/06 15:32:02
  12.  
  13. if ![info exists VERBOSE] {
  14.     set VERBOSE 0
  15. }
  16. if ![info exists TESTS] {
  17.     set TESTS {}
  18. }
  19.  
  20. tk appname tktest
  21. wm title . tktest
  22.  
  23. # Check configuration information that will determine which tests
  24. # to run.  To do this, create an array testConfig.  Each element
  25. # has a 0 or 1 value, and the following elements are defined:
  26. #    unixOnly -    1 means this is a UNIX platform, so it's OK
  27. #            to run tests that only work under UNIX.
  28. #    macOnly -    1 means this is a Mac platform, so it's OK
  29. #            to run tests that only work on Macs.
  30. #    pcOnly -    1 means this is a PC platform, so it's OK to
  31. #            run tests that only work on PCs.
  32. #    unixOrPc -    1 means this is a UNIX or PC platform.
  33. #    macOrPc -    1 means this is a Mac or PC platform.
  34. #    macOrUnix -    1 means this is a Mac or UNIX platform.
  35. #    nonPortable -    1 means this the tests are being running in
  36. #            the master Tcl/Tk development environment;
  37. #            Some tests are inherently non-portable because
  38. #            they depend on things like word length, file system
  39. #            configuration, window manager, etc.  These tests
  40. #            are only run in the main Tcl development directory
  41. #            where the configuration is well known.  The presence
  42. #            of the file "doAllTests" in this directory indicates
  43. #            that it is safe to run non-portable tests.
  44. #    fonts -        1 means that this platform uses fonts with
  45. #            well-know geometries, so it is safe to run
  46. #            tests that depend on particular font sizes.
  47.  
  48. catch {unset testConfig}
  49.  
  50. set testConfig(unixOnly)     [expr {$tcl_platform(platform) == "unix"}]
  51. set testConfig(macOnly)     [expr {$tcl_platform(platform) == "macintosh"}]
  52. set testConfig(pcOnly)        [expr {$tcl_platform(platform) == "windows"}]
  53.  
  54. set testConfig(unix)        $testConfig(unixOnly)
  55. set testConfig(mac)        $testConfig(macOnly)
  56. set testConfig(pc)        $testConfig(pcOnly)
  57.  
  58. set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
  59. set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
  60. set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
  61.  
  62. set testConfig(nonPortable)     [expr [file exists doAllTests] || [file exists DOALLT~1]]
  63.  
  64. set testConfig(nt)        [expr {$tcl_platform(os) == "Windows NT"}]
  65. set testConfig(95)        [expr {$tcl_platform(os) == "Windows 95"}]
  66. set testConfig(win32s)        [expr {$tcl_platform(os) == "Win32s"}]
  67.  
  68. # The following config switches are used to mark tests that should work,
  69. # but have been temporarily disabled on certain platforms because they don't.
  70.  
  71. set testConfig(tempNotPc)     [expr !$testConfig(pc)]
  72. set testConfig(tempNotMac)     [expr !$testConfig(mac)]
  73. set testConfig(tempNotUnix)    [expr !$testConfig(unix)]
  74.  
  75. # The following config switches are used to mark tests that crash on
  76. # certain platforms, so that they can be reactivated again when the
  77. # underlying problem is fixed.
  78.  
  79. set testConfig(pcCrash)     [expr !$testConfig(pc)]
  80. set testConfig(win32sCrash)     [expr !$testConfig(win32s)]
  81. set testConfig(macCrash)     [expr !$testConfig(mac)]
  82. set testConfig(unixCrash)     [expr !$testConfig(unix)]
  83.  
  84. set testConfig(fonts) 1
  85. catch {destroy .e}
  86. entry .e -width 0 -font {Helvetica -12} -bd 1
  87. .e insert end "a.bcd"
  88. if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
  89.     set testConfig(fonts) 0
  90. }
  91. destroy .e .t
  92. text .t -width 80 -height 20 -font {Times -14} -bd 1
  93. pack .t
  94. .t insert end "This is\na dot."
  95. update
  96. set x [list [.t bbox 1.3] [.t bbox 2.5]]
  97. destroy .t
  98. if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
  99.     set testConfig(fonts) 0
  100. }
  101.  
  102. if {$testConfig(nonPortable) == 0} {
  103.     puts "(will skip non-portable tests)"
  104. }
  105. if {$testConfig(fonts) == 0} {
  106.     puts "(will skip font-sensitive tests: this system has unexpected font geometries)"
  107. }
  108.  
  109. trace variable testConfig r safeFetch
  110.  
  111. proc safeFetch {n1 n2 op} {
  112.     global testConfig 
  113.  
  114.     if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
  115.     set testConfig($n2) 0
  116.     }
  117. }
  118.  
  119. # If there is no "memory" command (because memory debugging isn't
  120. # enabled), generate a dummy command that does nothing.
  121.  
  122. if {[info commands memory] == ""} {
  123.     proc memory args {}
  124. }
  125.  
  126. proc print_verbose {name description script code answer} {
  127.     puts stdout "\n"
  128.     puts stdout "==== $name $description"
  129.     puts stdout "==== Contents of test case:"
  130.     puts stdout "$script"
  131.     if {$code != 0} {
  132.     if {$code == 1} {
  133.         puts stdout "==== Test generated error:"
  134.         puts stdout $answer
  135.     } elseif {$code == 2} {
  136.         puts stdout "==== Test generated return exception;  result was:"
  137.         puts stdout $answer
  138.     } elseif {$code == 3} {
  139.         puts stdout "==== Test generated break exception"
  140.     } elseif {$code == 4} {
  141.         puts stdout "==== Test generated continue exception"
  142.     } else {
  143.         puts stdout "==== Test generated exception $code;  message was:"
  144.         puts stdout $answer
  145.     }
  146.     } else {
  147.     puts stdout "==== Result was:"
  148.     puts stdout "$answer"
  149.     }
  150. }
  151.  
  152. # test --
  153. # This procedure runs a test and prints an error message if the
  154. # test fails.  If VERBOSE has been set, it also prints a message
  155. # even if the test succeeds.  The test will be skipped if it
  156. # doesn't match the TESTS variable, or if one of the elements
  157. # of "constraints" turns out not to be true.
  158. #
  159. # Arguments:
  160. # name -        Name of test, in the form foo-1.2.
  161. # description -        Short textual description of the test, to
  162. #            help humans understand what it does.
  163. # constraints -        A list of one or more keywords, each of
  164. #            which must be the name of an element in
  165. #            the array "testConfig".  If any of these
  166. #            elements is zero, the test is skipped.
  167. #            This argument may be omitted.
  168. # script -        Script to run to carry out the test.  It must
  169. #            return a result that can be checked for
  170. #            correctness.
  171. # answer -        Expected result from script.
  172.  
  173. proc test {name description script answer args} {
  174.     global VERBOSE TESTS testConfig
  175.     if {[string compare $TESTS ""] != 0} {
  176.     set ok 0
  177.     foreach test $TESTS {
  178.         if {[string match $test $name]} {
  179.         set ok 1
  180.         break
  181.         }
  182.         }
  183.     if {!$ok} {
  184.         return
  185.     }
  186.     }
  187.     set i [llength $args]
  188.     if {$i == 0} {
  189.     # Empty body
  190.     } elseif {$i == 1} {
  191.     # "constraints" argument exists;  shuffle arguments down, then
  192.     # make sure that the constraints are satisfied.
  193.  
  194.     set constraints $script
  195.     set script $answer
  196.     set answer [lindex $args 0]
  197.     set doTest 0
  198.     if {[string match {*[$\[]*} $constraints] != 0} {
  199.         # full expression, e.g. {$foo > [info tclversion]}
  200.  
  201.         catch {set doTest [uplevel #0 expr $constraints]}
  202.     } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
  203.         # something like {a || b} should be turned into 
  204.         # $testConfig(a) || $testConfig(b).
  205.  
  206.          regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
  207.         catch {set doTest [eval expr $c]}
  208.     } else {
  209.         # just simple constraints such as {unixOnly fonts}.
  210.  
  211.         set doTest 1
  212.         foreach constraint $constraints {
  213.         if {![info exists testConfig($constraint)]
  214.             || !$testConfig($constraint)} {
  215.             set doTest 0
  216.             break
  217.         }
  218.         }
  219.     }
  220.     if {$doTest == 0} {
  221.         if {$VERBOSE} {
  222.         puts stdout "++++ $name SKIPPED: $constraints"
  223.         }
  224.         return    
  225.     }
  226.     } else {
  227.     error "wrong # args: must be \"test name description ?constraints? script answer\""
  228.     }
  229.     memory tag $name
  230.     set code [catch {uplevel $script} result]
  231.     if {$code != 0} {
  232.     print_verbose $name $description $script $code $result
  233.     } elseif {[string compare $result $answer] == 0} { 
  234.     if {$VERBOSE} then {
  235.         if {$VERBOSE > 0} {
  236.         print_verbose $name $description $script $code $result
  237.         }
  238.         if {$VERBOSE != -2} {
  239.         puts stdout "++++ $name PASSED"
  240.         }
  241.     }
  242.     } else { 
  243.     print_verbose $name $description $script $code $result 
  244.     puts stdout "---- Result should have been:"
  245.     puts stdout "$answer"
  246.     puts stdout "---- $name FAILED" 
  247.     }
  248. }
  249.  
  250. proc dotests {file args} {
  251.     global TESTS
  252.     set savedTests $TESTS
  253.     set TESTS $args
  254.     source $file
  255.     set TESTS $savedTests
  256. }
  257.  
  258. # If the main window isn't already mapped (e.g. because the tests are
  259. # being run automatically) , specify a precise size for it so that the
  260. # user won't have to position it manually.
  261.  
  262. if {![winfo ismapped .]} {
  263.     wm geometry . +0+0
  264.     update
  265. }
  266.  
  267. # The following code can be used to perform tests involving a second
  268. # process running in the background.
  269.  
  270. # Locate tktest executable
  271.  
  272. set tktest [info nameofexecutable]
  273. if {$tktest == "{}"} {
  274.     set tktest {}
  275.     puts "Unable to find tktest executable, skipping multiple process tests."
  276. }
  277.  
  278. # Create background process
  279.  
  280. proc setupbg {{args ""}} {
  281.     global tktest fd bgData
  282.     if {$tktest == ""} {
  283.         error "you're not running tktest so setupbg should not have been called"
  284.     }
  285.     if {[info exists fd] && ($fd != "")} {
  286.     cleanupbg
  287.     }
  288.     set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+]
  289.     puts $fd "puts foo; flush stdout"
  290.     flush $fd
  291.     if {[gets $fd data] < 0} {
  292.         error "unexpected EOF from \"$tktest\""
  293.     }
  294.     if [string compare $data foo] {
  295.         error "unexpected output from background process \"$data\""
  296.     }
  297.     fileevent $fd readable bgReady
  298. }
  299.  
  300. # Send a command to the background process, catching errors and
  301. # flushing I/O channels
  302. proc dobg {command} {
  303.     global fd bgData bgDone
  304.     puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
  305.     flush $fd
  306.     set bgDone 0
  307.     set bgData {}
  308.     tkwait variable bgDone
  309.     set bgData
  310. }
  311.  
  312. # Data arrived from background process.  Check for special marker
  313. # indicating end of data for this command, and make data available
  314. # to dobg procedure.
  315. proc bgReady {} {
  316.     global fd bgData bgDone
  317.     set x [gets $fd]
  318.     if [eof $fd] {
  319.     fileevent $fd readable {}
  320.     set bgDone 1
  321.     } elseif {$x == "**DONE**"} {
  322.     set bgDone 1
  323.     } else {
  324.     append bgData $x
  325.     }
  326. }
  327.  
  328. # Exit the background process, and close the pipes
  329. proc cleanupbg {} {
  330.     global fd
  331.     catch {
  332.     puts $fd "exit"
  333.     close $fd
  334.     }
  335.     set fd ""
  336. }
  337.  
  338. # Clean up focus after using generate event, which
  339. # can leave the window manager with the wrong impression
  340. # about who thinks they have the focus. (BW)
  341.  
  342. proc fixfocus {} {
  343.     catch {destroy .focus}
  344.     toplevel .focus
  345.     wm geometry .focus +0+0
  346.     entry .focus.e
  347.     .focus.e insert 0 "fixfocus"
  348.     pack .focus.e
  349.     update
  350.     focus -force .focus.e
  351.     destroy .focus
  352. }
  353.  
  354. proc makeFile {contents name} {
  355.     set fd [open $name w]
  356.     fconfigure $fd -translation lf
  357.     if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
  358.     puts -nonewline $fd $contents
  359.     } else {
  360.     puts $fd $contents
  361.     }
  362.     close $fd
  363. }
  364.  
  365. proc removeFile {name} {
  366.     file delete -- $name
  367. }
  368.